1. Загрузите датасет life_expectancy_data.RDS (лежит в папке
домашнего задания). Это данные с основными показателями, через которые
высчитывается ожидаемая продолжительности жизни по метрике World
Development Indicator на уровне стран. В данных оставлены строки,
относящиеся к положению женщин в 2019 г.
data <- read_rds("life_expectancy_data.RDS")
summary(data)
## Country Year Gender Life expectancy
## Length:195 Min. :2019 Length:195 Min. :55.49
## Class :character 1st Qu.:2019 Class :character 1st Qu.:70.02
## Mode :character Median :2019 Mode :character Median :77.55
## Mean :2019 Mean :75.52
## 3rd Qu.:2019 3rd Qu.:80.95
## Max. :2019 Max. :88.10
## Unemployment Infant Mortality GDP GNI
## Min. : 0.178 Min. : 1.40 Min. :1.884e+08 Min. :3.754e+08
## 1st Qu.: 3.735 1st Qu.: 5.35 1st Qu.:1.117e+10 1st Qu.:1.094e+10
## Median : 5.960 Median :13.50 Median :3.967e+10 Median :4.009e+10
## Mean : 8.597 Mean :19.61 Mean :4.660e+11 Mean :4.864e+11
## 3rd Qu.:10.958 3rd Qu.:30.23 3rd Qu.:2.476e+11 3rd Qu.:2.457e+11
## Max. :36.442 Max. :75.80 Max. :2.143e+13 Max. :2.171e+13
## Clean fuels and cooking technologies Per Capita
## Min. : 0.00 Min. : 228.2
## 1st Qu.: 34.50 1st Qu.: 2165.3
## Median : 80.70 Median : 6624.8
## Mean : 65.98 Mean : 16821.0
## 3rd Qu.:100.00 3rd Qu.: 19439.7
## Max. :100.00 Max. :175813.9
## Mortality caused by road traffic injury Tuberculosis Incidence
## Min. : 0.00 Min. : 0.0
## 1st Qu.: 8.20 1st Qu.: 12.0
## Median :16.00 Median : 46.0
## Mean :17.06 Mean :103.8
## 3rd Qu.:24.00 3rd Qu.:138.5
## Max. :64.60 Max. :654.0
## DPT Immunization HepB3 Immunization Measles Immunization Hospital beds
## Min. :35.00 Min. :35.00 Min. :37.00 Min. : 0.200
## 1st Qu.:85.69 1st Qu.:81.31 1st Qu.:84.85 1st Qu.: 1.301
## Median :92.00 Median :91.00 Median :92.00 Median : 2.570
## Mean :87.99 Mean :86.76 Mean :87.31 Mean : 2.997
## 3rd Qu.:97.00 3rd Qu.:96.00 3rd Qu.:96.50 3rd Qu.: 3.773
## Max. :99.00 Max. :99.00 Max. :99.00 Max. :13.710
## Basic sanitation services Tuberculosis treatment Urban population
## Min. : 8.632 Min. : 0.00 Min. : 13.25
## 1st Qu.: 62.919 1st Qu.: 73.00 1st Qu.: 41.92
## Median : 91.144 Median : 82.00 Median : 58.76
## Mean : 77.380 Mean : 77.57 Mean : 59.12
## 3rd Qu.: 98.582 3rd Qu.: 88.00 3rd Qu.: 78.02
## Max. :100.000 Max. :100.00 Max. :100.00
## Rural population Non-communicable Mortality Sucide Rate continent
## Min. : 0.00 Min. : 4.40 Min. : 0.300 Africa :52
## 1st Qu.:21.98 1st Qu.:11.85 1st Qu.: 2.050 Americas:38
## Median :41.24 Median :17.20 Median : 3.500 Asia :42
## Mean :40.88 Mean :17.05 Mean : 4.802 Europe :48
## 3rd Qu.:58.08 3rd Qu.:22.10 3rd Qu.: 6.600 Oceania :15
## Max. :86.75 Max. :43.70 Max. :30.100
str(data)
## Classes 'data.table' and 'data.frame': 195 obs. of 23 variables:
## $ Country : chr "Afghanistan" "Albania" "Algeria" "Angola" ...
## $ Year : int 2019 2019 2019 2019 2019 2019 2019 2019 2019 2019 ...
## $ Gender : chr "Female" "Female" "Female" "Female" ...
## $ Life expectancy : num 66.4 80.2 78.1 64 78.1 ...
## $ Unemployment : num 14.06 11.32 18.63 7.84 8.26 ...
## $ Infant Mortality : num 42.9 7.7 18.6 44.5 5.1 ...
## $ GDP : num 1.88e+10 1.54e+10 1.72e+11 8.94e+10 1.69e+09 ...
## $ GNI : num 1.91e+10 1.52e+10 1.68e+11 8.19e+10 1.58e+09 ...
## $ Clean fuels and cooking technologies : num 36 80.7 99.3 49.6 100 ...
## $ Per Capita : num 494 5396 3990 2810 17377 ...
## $ Mortality caused by road traffic injury: num 15.9 11.7 20.9 26.1 0 ...
## $ Tuberculosis Incidence : num 189 16 61 351 0 29 26 2.2 6.9 6 ...
## $ DPT Immunization : num 66 99 91 57 95 ...
## $ HepB3 Immunization : num 66 99 91 53 99 ...
## $ Measles Immunization : num 64 95 80 51 93 ...
## $ Hospital beds : num 0.432 3.052 1.8 0.8 2.581 ...
## $ Basic sanitation services : num 49 99.2 86.1 51.4 85.5 ...
## $ Tuberculosis treatment : num 91 88 86 69 72.3 ...
## $ Urban population : num 25.8 61.2 73.2 66.2 24.5 ...
## $ Rural population : num 74.2 38.8 26.8 33.8 75.5 ...
## $ Non-communicable Mortality : num 36.2 6 12.8 19.4 17.6 ...
## $ Sucide Rate : num 3.6 2.7 1.8 2.3 0.8 ...
## $ continent : Factor w/ 5 levels "Africa","Americas",..: 3 4 1 1 2 2 4 2 5 4 ...
## - attr(*, ".internal.selfref")=<externalptr>
## - attr(*, "sorted")= chr "Country"
2. Сделайте интерактивный plotly график любых двух нумерических
колонок. Раскрасть по колонке континента, на котором расположена
страна
plot_ly(
data = data,
x = ~ `Life expectancy`,
y = ~ `Unemployment`,
color = ~ continent) %>%
layout(
title = 'Отношение уровня ожидаемой продолжительности жизни к уровню безработицы',
yaxis = list(title = 'Продолжительность жизни',
zeroline = FALSE),
xaxis = list(title = 'Уровень безработицы',
zeroline = FALSE))
3. Проведите тест, на сравнение распределений колонки Life
expectancy между группами стран Африки и Америки. Вид статистического
теста определите самостоятельно. Визуализируйте результат через
библиотеку rstatix.
data2 <- data %>%
filter(.$continent == c('Africa', 'Americas')) %>%
select(`Life expectancy`, continent)
## Warning: There were 2 warnings in `filter()`.
## The first warning was:
## ℹ In argument: `.$continent == c("Africa", "Americas")`.
## Caused by warning in `==.default`:
## ! длина большего объекта не является произведением длины меньшего объекта
## ℹ Run `dplyr::last_dplyr_warnings()` to see the 1 remaining warning.
# Критерий Манна-Уитни-Уилкоксона для распределения ожидаемой продолжительности жизни в Америке и Африке
data2_aremicas <- data2 %>%
filter(.$continent == 'Americas')
data2_africa <- data2 %>%
filter(.$continent == 'Africa')
stat.test <- data2 %>%
wilcox_test(`Life expectancy` ~ continent) %>%
add_xy_position(x = "continent")
stat.test #p-value < 0.05, отвергаем нулевую гипотезу об отсутствии разницы средней продолжительности жизни в Африке и Америке - продолжительность жизни на этих континентах отличается
## # A tibble: 1 × 11
## .y. group1 group2 n1 n2 statistic p y.position groups xmin
## <chr> <chr> <chr> <int> <int> <dbl> <dbl> <dbl> <name> <dbl>
## 1 Life expe… Africa Ameri… 26 24 71 4.69e-7 86.6 <chr> 1
## # ℹ 1 more variable: xmax <dbl>
ggboxplot(
data2,
x = "continent", y = 'Life expectancy' ,
ylab = 'Life expectancy', xlab = "Continent",
add = "jitter",
) +
labs(subtitle = get_test_label(stat.test, detailed = TRUE)) +
stat_pvalue_manual(stat.test, tip.length = 0)

4. Сделайте новый датафрейм, в котором оставите все численные
колонки кроме Year. Сделайте корреляционный анализ этих данных.
Постройте два любых типа графиков для визуализации корреляций.
data3 <- data %>%
select(where(is.numeric), - Year)
cor_data3 <- cor(data3)
corrplot(cor_data3, method = "number", type = "lower", tl.cex = 0.5, number.cex = 0.5)

ggpairs(data3,
title = 'Correlations in Life expectancy dataset',progress = F) +
theme_minimal() +
scale_fill_manual(values = c('#b9c3a2')) +
scale_colour_manual(values = c('#b9c3a2'))

5. Постройте иерархическую кластеризацию на этом датафрейме.
scaled_data3 <- scale(data3)
scaled_dist <- dist(scaled_data3,
method = "euclidean")
as.matrix(scaled_dist)[1:6,1:6]
## 1 2 3 4 5 6
## 1 0.000000 7.605708 6.331840 4.414874 6.645623 7.923487
## 2 7.605708 0.000000 2.624659 7.921597 3.357361 3.631018
## 3 6.331840 2.624659 0.000000 6.321666 4.350331 3.464837
## 4 4.414874 7.921597 6.321666 0.000000 8.095849 7.161240
## 5 6.645623 3.357361 4.350331 8.095849 0.000000 4.966244
## 6 7.923487 3.631018 3.464837 7.161240 4.966244 0.000000
data_clear_hc <- hclust(d = scaled_dist,
method = "ward.D2")
fviz_dend(data_clear_hc,
cex = 0.1)
## Warning: The `<scale>` argument of `guides()` cannot be `FALSE`. Use "none" instead as
## of ggplot2 3.3.4.
## ℹ The deprecated feature was likely used in the factoextra package.
## Please report the issue at <https://github.com/kassambara/factoextra/issues>.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.

6. Сделайте одновременный график heatmap и иерархической
кластеризации. Содержательно интерпретируйте результат.
pheatmap(scaled_data3,
show_rownames = FALSE,
clustering_distance_rows = scaled_dist,
clustering_method = "ward.D2",
cutree_rows = 5,
cutree_cols = length(colnames(scaled_data3)),
angle_col = 45,
main = "Dendrograms for clustering rows and columns with heatmap")

# С помощью кластеризации возможно разбить колонкина несколько групп, описательные признаки образуют 4 основные группы (4 региона). В одном из регионов имеет место сильная корреляция по столбцам GDP и GNI. Между собой связаны столбцы о безработице, количестве заболеваний туберкулезом, детской смертности, в другую группу входят столбцы по иммунизации, отдельная группа - количество мест в больницах и число суицидов. По первой группе есть корреляция по одному из регионов.
7. Проведите PCA анализ на этих данных. Проинтерпретируйте
результат.
data_pca <- prcomp(data3, scale = T)
summary(data_pca)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.7526 1.4841 1.3952 1.17177 1.08375 0.96347 0.9288
## Proportion of Variance 0.3988 0.1159 0.1025 0.07227 0.06182 0.04886 0.0454
## Cumulative Proportion 0.3988 0.5147 0.6172 0.68945 0.75126 0.80012 0.8455
## PC8 PC9 PC10 PC11 PC12 PC13 PC14
## Standard deviation 0.85740 0.69263 0.68937 0.59106 0.54986 0.47085 0.36596
## Proportion of Variance 0.03869 0.02525 0.02501 0.01839 0.01591 0.01167 0.00705
## Cumulative Proportion 0.88421 0.90946 0.93447 0.95286 0.96877 0.98044 0.98749
## PC15 PC16 PC17 PC18 PC19
## Standard deviation 0.34546 0.26941 0.20224 0.06968 1.017e-15
## Proportion of Variance 0.00628 0.00382 0.00215 0.00026 0.000e+00
## Cumulative Proportion 0.99377 0.99759 0.99974 1.00000 1.000e+00
fviz_eig(data_pca, addlabels = T, ylim = c(0, 40))

fviz_pca_var(data_pca, col.var = "contrib")

fviz_pca_var(data_pca, select.var = list(contrib = 3),
col.var = "contrib") # сильная корреляция переменной Life expectations с 1 компонентой

fviz_contrib(data_pca, choice = "var", axes = 1, top = 24)

fviz_contrib(data_pca, choice = "var", axes = 2, top = 24)

fviz_contrib(data_pca, choice = "var", axes = 3, top = 24)

#первые две компоненты объясняют 50% дисперсии компонент
#большой вклад в анализируемые данные компоненты вносят переменные: Unemployment, suicide rate, tuberculosis treatment, hospital beds.
#можно выделить группы: "Immunization", 1 четверть и граница 2 и 3 четверти.
8. Постройте biplot график для PCA. Раскрасьте его по значениям
континентов. Переведите его в plotly. Желательно, чтобы при наведении на
точку, вы могли видеть название страны.
ggbiplot(data_pca,
scale=0, alpha = 0.1) +
theme_minimal()

data_clear_with_ch <- data %>%
select(-c(Country, Year, Gender))
ggplotly(ggbiplot(data_pca,
scale=0,
groups = as.factor(data_clear_with_ch$continent),
ellipse = T,
alpha = 0.2) +
theme_minimal())
9. Дайте содержательную интерпретацию PCA анализу.
#Данные могу быть объяснены 3 переменными. Есть переменные, которые имеют отрицательную корреляцию. На графике выше видны выбросы, данные можно кластеризовать по континентам, но не очень эффективно.
10. Сравните результаты отображения точек между алгоритмами PCA и
UMAP.
umap_prep <- recipe(~., data = data3) %>%
step_normalize(all_predictors()) %>%
step_umap(all_predictors()) %>%
prep() %>%
juice()
umap_prep %>%
ggplot(aes(UMAP1, UMAP2)) +
geom_point(aes(color = as.character(data_clear_with_ch$continent)),
alpha = 0.7, size = 2) +
labs(color = NULL)

#есть сходства в результатах отображения точек: точки Африканского континета аггрегируются в правом нижнем с углу, как и в PCA, видна аггрегация точек Европейского континента (как и в PCA), нет сильных выбросов в UMAP. В UMAP точки находятся более плотно, лучше видны кластеры.